home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / type-vops.lisp < prev    next >
Encoding:
Text File  |  1991-11-09  |  17.2 KB  |  532 lines
  1. ;;; -*- Package: MIPS -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: type-vops.lisp,v 1.32 91/11/09 02:37:45 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains the VM definition of type testing and checking VOPs
  15. ;;; for the RT.
  16. ;;;
  17. ;;; Written by Rob MacLachlan
  18. ;;;
  19. ;;; Converted for the MIPS R2000 by Christopher Hoover.
  20. ;;;
  21. (in-package "MIPS")
  22.  
  23.  
  24. ;;;; Simple type checking and testing:
  25. ;;;
  26. ;;;    These types are represented by a single type code, so are easily
  27. ;;; open-coded as non-shifting type test.
  28.  
  29. (define-vop (check-simple-type)
  30.   (:args
  31.    (value :target result
  32.       :scs (any-reg descriptor-reg)))
  33.   (:results
  34.    (result :scs (any-reg descriptor-reg)))
  35.   (:temporary (:type random :scs (non-descriptor-reg)) temp)
  36.   (:vop-var vop)
  37.   (:save-p :compute-only))
  38.  
  39. (define-vop (simple-type-predicate)
  40.   (:args
  41.    (value :scs (any-reg descriptor-reg)))
  42.   (:conditional)
  43.   (:info target not-p)
  44.   (:policy :fast-safe)
  45.   (:variant-vars type-code)
  46.   (:temporary (:type random :scs (non-descriptor-reg)) temp)
  47.   (:generator 4
  48.     (test-simple-type value temp target not-p type-code)))
  49.  
  50. (macrolet ((frob (pred-name check-name ptype type-code error-code)
  51.          (let ((cost (if (< (eval type-code) vm:lowtag-limit) 4 9)))
  52.            `(progn
  53.           (define-vop (,pred-name simple-type-predicate)
  54.             (:variant ,type-code)
  55.             (:variant-cost ,cost)
  56.             (:translate ,pred-name))
  57.           (define-vop (,check-name check-simple-type)
  58.             (:generator ,cost
  59.               (let ((err-lab
  60.                  (generate-error-code vop ,error-code value)))
  61.             (test-simple-type value temp err-lab t ,type-code)
  62.             (move result value))))
  63.           (primitive-type-vop ,check-name (:check) ,ptype)))))
  64.  
  65.   (frob functionp check-function function
  66.     vm:function-pointer-type object-not-function-error)
  67.  
  68.   (frob listp check-list list
  69.     vm:list-pointer-type object-not-list-error)
  70.  
  71.   (frob structurep check-structure structure
  72.     vm:structure-pointer-type object-not-structure-error)
  73.  
  74.   (frob bignump check-bigunm bignum
  75.     vm:bignum-type object-not-bignum-error)
  76.  
  77.   (frob ratiop check-ratio ratio
  78.     vm:ratio-type object-not-ratio-error)
  79.  
  80.   (frob complexp check-complex complex
  81.     vm:complex-type object-not-complex-error)
  82.  
  83.   (frob single-float-p check-single-float single-float
  84.     vm:single-float-type object-not-single-float-error)
  85.  
  86.   (frob double-float-p check-double-float double-float
  87.     vm:double-float-type object-not-double-float-error)
  88.  
  89.   (frob simple-string-p check-simple-string simple-string
  90.     vm:simple-string-type object-not-simple-string-error)
  91.  
  92.   (frob simple-bit-vector-p check-simple-bit-vector simple-bit-vector
  93.     vm:simple-bit-vector-type object-not-simple-bit-vector-error)
  94.  
  95.   (frob simple-vector-p check-simple-vector simple-vector
  96.     vm:simple-vector-type object-not-simple-vector-error)
  97.  
  98.   (frob simple-array-unsigned-byte-2-p check-simple-array-unsigned-byte-2
  99.     simple-array-unsigned-byte-2 vm:simple-array-unsigned-byte-2-type
  100.     object-not-simple-array-unsigned-byte-2-error)
  101.  
  102.   (frob simple-array-unsigned-byte-4-p check-simple-array-unsigned-byte-4
  103.     simple-array-unsigned-byte-4 vm:simple-array-unsigned-byte-4-type
  104.     object-not-simple-array-unsigned-byte-4-error)
  105.  
  106.   (frob simple-array-unsigned-byte-8-p check-simple-array-unsigned-byte-8
  107.     simple-array-unsigned-byte-8 vm:simple-array-unsigned-byte-8-type
  108.     object-not-simple-array-unsigned-byte-8-error)
  109.  
  110.   (frob simple-array-unsigned-byte-16-p check-simple-array-unsigned-byte-16
  111.     simple-array-unsigned-byte-16 vm:simple-array-unsigned-byte-16-type
  112.     object-not-simple-array-unsigned-byte-16-error)
  113.  
  114.   (frob simple-array-unsigned-byte-32-p check-simple-array-unsigned-byte-32
  115.     simple-array-unsigned-byte-32 vm:simple-array-unsigned-byte-32-type
  116.     object-not-simple-array-unsigned-byte-32-error)
  117.  
  118.   (frob simple-array-single-float-p check-simple-array-single-float
  119.     simple-array-single-float vm:simple-array-single-float-type
  120.     object-not-simple-array-single-float-error)
  121.  
  122.   (frob simple-array-double-float-p check-simple-array-double-float
  123.     simple-array-double-float vm:simple-array-double-float-type
  124.     object-not-simple-array-double-float-error)
  125.  
  126.   (frob base-char-p check-base-char base-char
  127.     vm:base-char-type object-not-base-char-error)
  128.  
  129.   (frob system-area-pointer-p check-system-area-pointer system-area-pointer
  130.     vm:sap-type object-not-sap-error)
  131.  
  132.   (frob weak-pointer-p check-weak-pointer weak-pointer
  133.     vm:weak-pointer-type object-not-weak-pointer-error))
  134.  
  135. (define-vop (funcallable-instance-p simple-type-predicate)
  136.   (:translate funcallable-instance-p)
  137.   (:variant-vars)
  138.   (:generator 4
  139.     (test-simple-type value temp target not-p
  140.               vm:funcallable-instance-header-type
  141.               :lowtag vm:function-pointer-type)))
  142.  
  143. (define-vop (code-component-p simple-type-predicate)
  144.   (:variant code-header-type)
  145.   (:variant-cost 9)
  146.   (:translate code-component-p))
  147.  
  148. (define-vop (lra-p simple-type-predicate)
  149.   (:variant return-pc-header-type)
  150.   (:variant-cost 9)
  151.   (:translate lra-p))
  152.  
  153. (define-vop (scavenger-hook-p simple-type-predicate)
  154.   (:variant 0)
  155.   (:variant-cost 9)
  156.   (:translate scavenger-hook-p))
  157.  
  158.  
  159. ;;; Slightly tenser versions for FIXNUM's
  160. ;;; 
  161. (define-vop (check-fixnum check-simple-type)
  162.   (:generator 3
  163.     (let ((err-lab (generate-error-code vop object-not-fixnum-error value)))
  164.       (inst and temp value #x3)
  165.       (inst bne temp zero-tn err-lab)
  166.       (move result value t))))
  167.  
  168. (primitive-type-vop check-fixnum (:check) fixnum)
  169.  
  170. (define-vop (fixnump simple-type-predicate)
  171.   (:ignore type-code)
  172.   (:translate ext:fixnump)
  173.   (:generator 3
  174.     (inst and temp value #x3)
  175.     (if not-p
  176.     (inst bne temp zero-tn target)
  177.     (inst beq temp zero-tn target))
  178.     (inst nop)))
  179.  
  180.  
  181. ;;;; Hairy type tests:
  182. ;;;
  183. ;;;    These types are represented by a union of type codes.  
  184. ;;;
  185.  
  186. (define-vop (hairy-type-predicate)
  187.   (:args
  188.    (obj :scs (any-reg descriptor-reg)
  189.     :target temp))
  190.   (:conditional)
  191.   (:info target not-p)
  192.   (:policy :fast-safe)
  193.   (:temporary (:type random :scs (non-descriptor-reg)) temp))
  194.  
  195. (define-vop (check-hairy-type)
  196.   (:args
  197.    (obj :scs (any-reg descriptor-reg)
  198.     :target res))
  199.   (:results
  200.    (res :scs (any-reg descriptor-reg)))
  201.   (:temporary (:type random :scs (non-descriptor-reg)) temp)
  202.   (:vop-var vop)
  203.   (:save-p :compute-only))
  204.  
  205. (macrolet ((frob (pred-name check-name error-code &rest types)
  206.          (let ((cost (* (+ (length types)
  207.                    (count-if #'consp types))
  208.                 4)))
  209.            `(progn
  210.           ,@(when pred-name
  211.               `((define-vop (,pred-name hairy-type-predicate)
  212.               (:translate ,pred-name)
  213.               (:generator ,cost
  214.                 (test-hairy-type obj temp target not-p ,@types)))))
  215.             
  216.           ,@(when check-name
  217.               `((define-vop (,check-name check-hairy-type)
  218.               (:generator ,cost
  219.                 (let ((err-lab (generate-error-code vop
  220.                                 ,error-code
  221.                                 obj)))
  222.                   (test-hairy-type obj temp err-lab t ,@types))
  223.                 (move res obj)))))))))
  224.  
  225.   (frob array-header-p nil nil
  226.     vm:simple-array-type vm:complex-string-type vm:complex-bit-vector-type
  227.     vm:complex-vector-type vm:complex-array-type)
  228.  
  229.   (frob stringp check-string object-not-string-error
  230.     vm:simple-string-type vm:complex-string-type)
  231.  
  232.   (frob bit-vector-p check-bit-vector object-not-bit-vector-error
  233.     vm:simple-bit-vector-type vm:complex-bit-vector-type)
  234.  
  235.   (frob vectorp check-vector object-not-vector-error
  236.     vm:simple-string-type vm:simple-bit-vector-type vm:simple-vector-type
  237.     vm:simple-array-unsigned-byte-2-type vm:simple-array-unsigned-byte-4-type
  238.     vm:simple-array-unsigned-byte-8-type vm:simple-array-unsigned-byte-16-type
  239.     vm:simple-array-unsigned-byte-32-type vm:simple-array-single-float-type
  240.     vm:simple-array-double-float-type vm:complex-string-type
  241.     vm:complex-bit-vector-type vm:complex-vector-type)
  242.  
  243.   (frob simple-array-p check-simple-array object-not-simple-array-error
  244.     vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
  245.     vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
  246.     vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
  247.     vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
  248.     vm:simple-array-single-float-type vm:simple-array-double-float-type)
  249.  
  250.   (frob arrayp check-array object-not-array-error
  251.     vm:simple-array-type vm:simple-string-type vm:simple-bit-vector-type
  252.     vm:simple-vector-type vm:simple-array-unsigned-byte-2-type
  253.     vm:simple-array-unsigned-byte-4-type vm:simple-array-unsigned-byte-8-type
  254.     vm:simple-array-unsigned-byte-16-type vm:simple-array-unsigned-byte-32-type
  255.     vm:simple-array-single-float-type vm:simple-array-double-float-type
  256.     vm:complex-string-type vm:complex-bit-vector-type vm:complex-vector-type
  257.     vm:complex-array-type)
  258.     
  259.   (frob numberp check-number object-not-number-error
  260.     vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type vm:ratio-type
  261.     vm:single-float-type vm:double-float-type vm:complex-type)
  262.  
  263.   (frob rationalp check-rational object-not-rational-error
  264.     vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type)
  265.  
  266.   (frob floatp check-float object-not-float-error
  267.     vm:single-float-type vm:double-float-type)
  268.  
  269.   (frob realp check-real object-not-real-error
  270.     vm:even-fixnum-type vm:odd-fixnum-type vm:ratio-type vm:bignum-type
  271.     vm:single-float-type vm:double-float-type)
  272.   
  273.   ;; ### May want to make this more tense.
  274.   (frob integerp check-integer object-not-integer-error
  275.     vm:even-fixnum-type vm:odd-fixnum-type vm:bignum-type))
  276.  
  277.  
  278. ;;;; Other integer ranges.
  279.  
  280. ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
  281. ;;; exactly one digit.
  282.  
  283. (define-vop (signed-byte-32-p hairy-type-predicate)
  284.   (:translate signed-byte-32-p)
  285.   (:generator 45
  286.     (let ((not-target (gen-label)))
  287.       (multiple-value-bind
  288.       (yep nope)
  289.       (if not-p
  290.           (values not-target target)
  291.           (values target not-target))
  292.     (inst and temp obj #x3)
  293.     (inst beq temp zero-tn yep)
  294.     (test-simple-type obj temp nope t vm:bignum-type)
  295.     (loadw temp obj 0 vm:other-pointer-type)
  296.     (inst srl temp temp (1+ vm:type-bits))
  297.     (if not-p
  298.         (inst bne temp zero-tn target)
  299.         (inst beq temp zero-tn target))
  300.     (inst nop)
  301.     (emit-label not-target)))))
  302.  
  303. (define-vop (check-signed-byte-32 check-hairy-type)
  304.   (:generator 45
  305.     (let ((nope (generate-error-code vop object-not-signed-byte-32-error obj))
  306.       (yep (gen-label)))
  307.       (inst and temp obj #x3)
  308.       (inst beq temp zero-tn yep)
  309.       (test-simple-type obj temp nope t vm:bignum-type)
  310.       (loadw temp obj 0 vm:other-pointer-type)
  311.       (inst srl temp temp (1+ vm:type-bits))
  312.       (inst bne temp zero-tn nope)
  313.       (inst nop)
  314.       (emit-label yep)
  315.       (move res obj))))
  316.  
  317.  
  318. ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
  319. ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
  320. ;;; and the second digit all zeros.
  321.  
  322. (define-vop (unsigned-byte-32-p hairy-type-predicate)
  323.   (:translate unsigned-byte-32-p)
  324.   (:generator 45
  325.     (let ((not-target (gen-label))
  326.       (single-word (gen-label))
  327.       (fixnum (gen-label)))
  328.       (multiple-value-bind
  329.       (yep nope)
  330.       (if not-p
  331.           (values not-target target)
  332.           (values target not-target))
  333.     ;; Is it a fixnum?
  334.     (inst and temp obj #x3)
  335.     (inst beq temp zero-tn fixnum)
  336.     ;; If not, is it a bignum?
  337.     (test-simple-type obj temp nope t vm:bignum-type)
  338.     ;; Get the number of digits.
  339.     (loadw temp obj 0 vm:other-pointer-type)
  340.     (inst srl temp temp vm:type-bits)
  341.     ;; Is it one?
  342.     (inst addu temp -1)
  343.     (inst beq temp single-word)
  344.     ;; If it's other than two, we can't be an (unsigned-byte 32)
  345.     (inst addu temp -1)
  346.     (inst bne temp nope)
  347.     ;; Get the second digit.
  348.     (loadw temp obj (1+ vm:bignum-digits-offset) vm:other-pointer-type)
  349.     ;; All zeros, its an (unsigned-byte 32).
  350.     (inst beq temp yep)
  351.     (inst nop)
  352.     ;; Otherwise, it isn't.
  353.     (inst b nope)
  354.     (inst nop)
  355.     
  356.     (emit-label single-word)
  357.     ;; Get the single digit.
  358.     (loadw temp obj vm:bignum-digits-offset vm:other-pointer-type)
  359.     ;; positive implies (unsigned-byte 32).
  360.     (inst bgez temp yep)
  361.     (inst nop)
  362.     ;; Otherwise, nope.
  363.     (inst b nope)
  364.     (inst nop)
  365.  
  366.     (emit-label fixnum)
  367.     ;; positive fixnums are (unsigned-byte 32).
  368.     (if not-p
  369.         (inst bltz obj target)
  370.         (inst bgez obj target))
  371.     (inst nop)
  372.  
  373.     (emit-label not-target)))))      
  374.  
  375. (define-vop (check-unsigned-byte-32 check-hairy-type)
  376.   (:generator 45
  377.     (let ((nope
  378.        (generate-error-code vop object-not-unsigned-byte-32-error obj))
  379.       (yep (gen-label))
  380.       (fixnum (gen-label))
  381.       (single-word (gen-label)))
  382.       ;; Is it a fixnum?
  383.       (inst and temp obj #x3)
  384.       (inst beq temp zero-tn fixnum)
  385.       ;; If not, is it a bignum?
  386.       (test-simple-type obj temp nope t vm:bignum-type)
  387.       ;; Get the number of digits.
  388.       (loadw temp obj 0 vm:other-pointer-type)
  389.       (inst srl temp temp vm:type-bits)
  390.       ;; Is it one?
  391.       (inst addu temp -1)
  392.       (inst beq temp single-word)
  393.       ;; If it's other than two, we can't be an (unsigned-byte 32)
  394.       (inst addu temp -1)
  395.       (inst bne temp nope)
  396.       ;; Get the second digit.
  397.       (loadw temp obj (1+ vm:bignum-digits-offset) vm:other-pointer-type)
  398.       ;; All zeros, its an (unsigned-byte 32).
  399.       (inst beq temp yep)
  400.       (inst nop)
  401.       ;; Otherwise, it isn't.
  402.       (inst b nope)
  403.       (inst nop)
  404.       
  405.       (emit-label single-word)
  406.       ;; Get the single digit.
  407.       (loadw temp obj vm:bignum-digits-offset vm:other-pointer-type)
  408.       ;; positive implies (unsigned-byte 32).
  409.       (inst bgez temp yep)
  410.       (inst nop)
  411.       ;; Otherwise, nope.
  412.       (inst b nope)
  413.       (inst nop)
  414.       
  415.       (emit-label fixnum)
  416.       ;; positive fixnums are (unsigned-byte 32).
  417.       (inst bltz obj nope)
  418.       (inst nop)
  419.       
  420.       (emit-label yep)
  421.       (move res obj))))
  422.  
  423.  
  424.  
  425.  
  426. ;;;; List/symbol types:
  427. ;;; 
  428. ;;; symbolp (or symbol (eq nil))
  429. ;;; consp (and list (not (eq nil)))
  430.  
  431. (define-vop (list-symbol-predicate)
  432.   (:args
  433.    (obj :scs (any-reg descriptor-reg)))
  434.   (:conditional)
  435.   (:info target not-p)
  436.   (:policy :fast-safe)
  437.   (:temporary (:type random  :scs (non-descriptor-reg)) temp)))
  438.  
  439. (define-vop (check-list-symbol check-hairy-type)
  440.   (:temporary (:type random  :scs (non-descriptor-reg)) temp))
  441.  
  442.  
  443. (macrolet ((frob (pred-name check-name error-code &rest body)
  444.          `(progn
  445.         (define-vop (,pred-name list-symbol-predicate)
  446.           (:translate ,pred-name)
  447.           (:generator 8
  448.             ,@body))
  449.         (define-vop (,check-name check-list-symbol)
  450.           (:generator 8
  451.             (let ((target (generate-error-code vop ,error-code obj))
  452.               (not-p t))
  453.               ,@body
  454.               (move res obj)))))))
  455.  
  456.   (frob symbolp check-symbol object-not-symbol-error
  457.     (let* ((drop-thru (gen-label))
  458.        (is-symbol-label (if not-p drop-thru target)))
  459.       (inst beq obj null-tn is-symbol-label)
  460.       (inst nop)
  461.       (test-simple-type obj temp target not-p vm:symbol-header-type)
  462.       (emit-label drop-thru)))
  463.  
  464.   (frob consp check-cons object-not-cons-error
  465.     (let* ((drop-thru (gen-label))
  466.        (is-not-cons-label (if not-p target drop-thru)))
  467.       (inst beq obj null-tn is-not-cons-label)
  468.       (inst nop)
  469.       (test-simple-type obj temp target not-p vm:list-pointer-type)
  470.       (emit-label drop-thru))))
  471.  
  472.  
  473. ;;;; Function Coercion
  474.  
  475. ;;; If not a function, get the symbol value and test for that being a
  476. ;;; function.  Since we test for a function rather than the unbound
  477. ;;; marker, this works on NIL.
  478. ;;;
  479. (define-vop (coerce-to-function)
  480.   (:args (object :scs (descriptor-reg)
  481.         :target result))
  482.   (:results (result :scs (descriptor-reg)))
  483.   (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
  484.   (:temporary (:scs (descriptor-reg)) saved-object)
  485.   (:vop-var vop)
  486.   (:save-p :compute-only)
  487.   (:generator 0
  488.     (let ((not-function-label (gen-label))
  489.       (not-coercable-label (gen-label))
  490.       (done-label (gen-label)))
  491.       (test-simple-type object nd-temp not-function-label t
  492.             vm:function-pointer-type)
  493.       (move result object)
  494.       (emit-label done-label)
  495.  
  496.       (assemble (*elsewhere*)
  497.     (emit-label not-function-label)
  498.     (test-simple-type object nd-temp not-coercable-label t
  499.               vm:symbol-header-type)
  500.     (move saved-object object)
  501.     (loadw result object vm:symbol-function-slot vm:other-pointer-type)
  502.     (test-simple-type result nd-temp done-label nil
  503.               vm:function-pointer-type)
  504.     (error-call vop undefined-symbol-error saved-object)
  505.     
  506.     (emit-label not-coercable-label)
  507.     (error-call vop object-not-coercable-to-function-error object)))))
  508.  
  509. (define-vop (fast-safe-coerce-to-function)
  510.   (:args (object :scs (descriptor-reg)
  511.         :target result))
  512.   (:results (result :scs (descriptor-reg)))
  513.   (:temporary (:type random  :scs (non-descriptor-reg)) nd-temp)
  514.   (:temporary (:scs (descriptor-reg)) saved-object)
  515.   (:vop-var vop)
  516.   (:save-p :compute-only)
  517.   (:generator 0
  518.     (let ((not-function-label (gen-label))
  519.       (done-label (gen-label)))
  520.       (test-simple-type object nd-temp not-function-label t
  521.             vm:function-pointer-type)
  522.       (move result object)
  523.       (emit-label done-label)
  524.  
  525.       (assemble (*elsewhere*)
  526.     (emit-label not-function-label)
  527.     (move saved-object object)
  528.     (loadw result object vm:symbol-function-slot vm:other-pointer-type)
  529.     (test-simple-type result nd-temp done-label nil
  530.               vm:function-pointer-type)
  531.     (error-call vop undefined-symbol-error saved-object)))))
  532.